home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / pc / files / ant_nec / nec81tar.z / nec81tar / netwk.f < prev    next >
Text File  |  1991-05-13  |  18KB  |  655 lines
  1. C $TITLE: 'NETWK'
  2. C $NOFLOATCALLS
  3. C
  4. C
  5. C
  6.       SUBROUTINE NETWK(CM,CMB,CMC,CMD,EINC,RHS,SCRATC,
  7.      1 AIR,AII,BIR,BII,CIR,CII,T1X,T1Y,T1Z,T2X,T2Y,T2Z,BI,
  8.      2 ICON1,ICON2,ITAG,IP,IW,LD,LD2,LD3,IRESRV)
  9. C
  10. C     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN
  11. C     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF
  12. C     PRESENT.
  13. C
  14.       REAL*8 TP,AIR,AII,BIR,BII,CIR,CII,ASA,ASM,PWR
  15. CLARGE: CM,CMB,CMC,CMD,CMN,EINC,RHS,RHNT
  16.       COMPLEX CM,CMB,CMC,CMD,CMN,EINC,RHS,RHNT
  17.       COMPLEX*16 SCRATC
  18.       COMPLEX*16 VQD,VSANT,VQDS
  19.       COMPLEX*16 VSRC,RHNX,ZPED
  20.       COMPLEX*16 YMIT,VLT,CUX
  21.       INTEGER*4 NEQ,NPEQ,NEQ2,NTEQ,NDIMN,NEQT
  22.       INTEGER*4 ICON1,ICON2,ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
  23.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  24.       COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
  25.      1 IQDS(30),NVQD,NSANT,NQDS
  26.       COMMON/NETCX/ZPED,PIN,PNLS,NEQ,NPEQ,NEQ2,NONET,NTSOL,NPRINT,
  27.      1 MASYM,ISEG1(30),ISEG2(30),X11R(30),X11I(30),X12R(30),X12I(30),
  28.      2 X22R(30),X22I(30),NTYP(30)
  29.       COMMON/NETWKC/CMN(30,30),RHNT(30),IPNT(30),NTEQA(30),NTSCA(30),
  30.      1 VSRC(30),RHNX(30),NAMPRT
  31.       DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),BI(LD)
  32.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  33.       DIMENSION CM(IRESRV),EINC(LD3),CMB(1),CMC(1),CMD(1),SCRATC(LD2),
  34.      1 RHS(LD3),IP(LD2),ICON1(LD),ICON2(LD),ITAG(LD)
  35. C**
  36. C $NODEBUG
  37. C**
  38. C      DATA NDIMN,NDIMNP/30,31/,TP/6.283185308D0/
  39.       DATA NDIMN,NDIMNP/100,101/,TP/6.283185308D0/
  40. C**
  41. C     D      WRITE(*,*) '  NETWK: START'
  42. C**
  43. $DEBUG
  44. C**
  45.       NEQZ2=NEQ2
  46.       IF(NEQZ2.EQ.0)NEQZ2=1
  47.       PIN=0.
  48.       PNLS=0.
  49.       NEQT=NEQ+NEQ2
  50.       IF (NTSOL.NE.0) GO TO 42
  51.       NOP=NEQ/NPEQ
  52. C**
  53.       IF((MASYM.EQ.0).OR.(NAMPRT.NE.0)) GO TO 14
  54. C
  55. C     COMPUTE RELATIVE MATRIX ASYMMETRY
  56. C
  57. C**
  58. C     D      WRITE(*,*) '  NETWK: COMPUTE RELATIVE MATRIX ASYMMETRY'
  59. C**
  60.       IROW1=0
  61.       IF (NONET.EQ.0) GO TO 5
  62.       DO 4 I=1,NONET
  63.       NSEG1=ISEG1(I)
  64.       DO 3 ISC1=1,2
  65.       IF (IROW1.EQ.0) GO TO 2
  66.       DO 1 J=1,IROW1
  67.       IF (NSEG1.EQ.IPNT(J)) GO TO 3
  68. 1     CONTINUE
  69. 2     IROW1=IROW1+1
  70.       IPNT(IROW1)=NSEG1
  71. 3     NSEG1=ISEG2(I)
  72. 4     CONTINUE
  73. 5     IF (NSANT.EQ.0) GO TO 9
  74.       DO 8 I=1,NSANT
  75.       NSEG1=ISANT(I)
  76.       IF (IROW1.EQ.0) GO TO 7
  77.       DO 6 J=1,IROW1
  78.       IF (NSEG1.EQ.IPNT(J)) GO TO 8
  79. 6     CONTINUE
  80. 7     IROW1=IROW1+1
  81.       IPNT(IROW1)=NSEG1
  82. 8     CONTINUE
  83. 9     IF (IROW1.LT.NDIMNP) GO TO 10
  84.       WRITE(IW,59)
  85.       STOP
  86. 10    IF (IROW1.LT.2) GO TO 14
  87.       DO 12 I=1,IROW1
  88.       ISC1=IPNT(I)
  89.       ASM=T1X(ISC1)
  90.       DO 11 J=1,NEQT
  91. 11    RHS(J)= CMPLX(0.,0.)
  92.       RHS(ISC1)= CMPLX(1.,0.)
  93. C**
  94. C     D      WRITE(*,*) '  NETWK: CALL SOLGF AFTER 11'
  95. C**
  96.       CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
  97.      1 NEQZ2,IP,LD2,LD3,IRESRV)
  98. C**
  99. C     D      WRITE(*,*) '  NETWK: RTRN SOLGF AFTER 11'
  100. C     D      WRITE(*,*) '  NETWK: CALL CABC AFTER 11'
  101. C**
  102.       CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  103.      1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
  104. C**
  105. C     D      WRITE(*,*) '  NETWK: RTRN CABC AFTER 11'
  106. C**
  107.       DO 12 J=1,IROW1
  108.       ISC1=IPNT(J)
  109. 12    CMN(J,I)=RHS(ISC1)/ASM
  110.       ASM=0.
  111.       ASA=0.
  112.       DO 13 I=2,IROW1
  113.       ISC1=I-1
  114.       DO 13 J=1,ISC1
  115.       CUX=CMN(I,J)
  116. C      PWR=CABS((CUX-CMN(J,I))/CUX)
  117.       PWR=ZABS((CUX-CMN(J,I))/CUX)
  118.       ASA=ASA+PWR*PWR
  119.       IF (PWR.LT.ASM) GO TO 13
  120.       ASM=PWR
  121.       NTEQ=IPNT(I)
  122.       NTSC=IPNT(J)
  123. 13    CONTINUE
  124. C**
  125.       ASA=DSQRT(ASA*2./FLOAT(IROW1*(IROW1-1)))
  126.       WRITE(IW,58)  ASM,NTEQ,NTSC,ASA
  127. 14    IF (NONET.EQ.0) GO TO 48
  128. C
  129. C     SOLUTION OF NETWORK EQUATIONS
  130. C
  131.       DO 15 I=1,NDIMN
  132.       RHNX(I)=DCMPLX(0.,0.)
  133.       DO 15 J=1,NDIMN
  134. 15    CMN(I,J)= CMPLX(0.,0.)
  135.       NTEQ=0
  136.       NTSC=0
  137. C
  138. C     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO
  139. C     SEGMENTS.
  140. C
  141.       DO 38 J=1,NONET
  142.       NSEG1=ISEG1(J)
  143.       NSEG2=ISEG2(J)
  144.       IF (NTYP(J).GT.1) GO TO 16
  145.       Y11R=X11R(J)
  146.       Y11I=X11I(J)
  147.       Y12R=X12R(J)
  148.       Y12I=X12I(J)
  149.       Y22R=X22R(J)
  150.       Y22I=X22I(J)
  151.       GO TO 17
  152. 16    Y22R=TP*X11I(J)/WLAM
  153.       Y12R=0.
  154.       Y12I=1./(X11R(J)*SIN(Y22R))
  155.       Y11R=X12R(J)
  156.       Y11I=-Y12I*COS(Y22R)
  157.       Y22R=X22R(J)
  158.       Y22I=Y11I+X22I(J)
  159.       Y11I=Y11I+X12I(J)
  160.       IF (NTYP(J).EQ.2) GO TO 17
  161.       Y12R=-Y12R
  162.       Y12I=-Y12I
  163. 17    IF (NSANT.EQ.0) GO TO 19
  164.       DO 18 I=1,NSANT
  165.       IF (NSEG1.NE.ISANT(I)) GO TO 18
  166.       ISC1=I
  167.       GO TO 22
  168. 18    CONTINUE
  169. 19    ISC1=0
  170.       IF (NTEQ.EQ.0) GO TO 21
  171.       DO 20 I=1,NTEQ
  172.       IF (NSEG1.NE.NTEQA(I)) GO TO 20
  173.       IROW1=I
  174.       GO TO 25
  175. 20    CONTINUE
  176. 21    NTEQ=NTEQ+1
  177.       IROW1=NTEQ
  178.       NTEQA(NTEQ)=NSEG1
  179.       GO TO 25
  180. 22    IF (NTSC.EQ.0) GO TO 24
  181.       DO 23 I=1,NTSC
  182.       IF (NSEG1.NE.NTSCA(I)) GO TO 23
  183.       IROW1=NDIMNP-I
  184.       GO TO 25
  185. 23    CONTINUE
  186. 24    NTSC=NTSC+1
  187.       IROW1=NDIMNP-NTSC
  188.       NTSCA(NTSC)=NSEG1
  189.       VSRC(NTSC)=VSANT(ISC1)
  190. 25    IF (NSANT.EQ.0) GO TO 27
  191.       DO 26 I=1,NSANT
  192.       IF (NSEG2.NE.ISANT(I)) GO TO 26
  193.       ISC2=I
  194.       GO TO 30
  195. 26    CONTINUE
  196. 27    ISC2=0
  197.       IF (NTEQ.EQ.0) GO TO 29
  198.       DO 28 I=1,NTEQ
  199.       IF (NSEG2.NE.NTEQA(I)) GO TO 28
  200.       IROW2=I
  201.       GO TO 33
  202. 28    CONTINUE
  203. 29    NTEQ=NTEQ+1
  204.       IROW2=NTEQ
  205.       NTEQA(NTEQ)=NSEG2
  206.       GO TO 33
  207. 30    IF (NTSC.EQ.0) GO TO 32
  208.       DO 31 I=1,NTSC
  209.       IF (NSEG2.NE.NTSCA(I)) GO TO 31
  210.       IROW2=NDIMNP-I
  211.       GO TO 33
  212. 31    CONTINUE
  213. 32    NTSC=NTSC+1
  214.       IROW2=NDIMNP-NTSC
  215.       NTSCA(NTSC)=NSEG2
  216.       VSRC(NTSC)=VSANT(ISC2)
  217. 33    IF (NTSC+NTEQ.LT.NDIMNP) GO TO 34
  218.       WRITE(IW,59)
  219.       STOP
  220. C
  221. C     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
  222. C     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
  223. C
  224. 34    IF (ISC1.NE.0) GO TO 35
  225.       CMN(IROW1,IROW1)=CMN(IROW1,IROW1)-CMPLX(Y11R,Y11I)*T1X(NSEG1)
  226.       CMN(IROW1,IROW2)=CMN(IROW1,IROW2)-CMPLX(Y12R,Y12I)*T1X(NSEG1)
  227.       GO TO 36
  228. 35    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y11R,Y11I)*VSANT(ISC1)/WLAM
  229.       RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y12R,Y12I)*VSANT(ISC1)/WLAM
  230. 36    IF (ISC2.NE.0) GO TO 37
  231.       CMN(IROW2,IROW2)=CMN(IROW2,IROW2)-CMPLX(Y22R,Y22I)*T1X(NSEG2)
  232.       CMN(IROW2,IROW1)=CMN(IROW2,IROW1)-CMPLX(Y12R,Y12I)*T1X(NSEG2)
  233.       GO TO 38
  234. 37    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y12R,Y12I)*VSANT(ISC2)/WLAM
  235.       RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y22R,Y22I)*VSANT(ISC2)/WLAM
  236. 38    CONTINUE
  237. C
  238. C     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
  239. C     MATRIX
  240. C
  241.       DO 41 I=1,NTEQ
  242.       DO 39 J=1,NEQT
  243. 39    RHS(J)=(0.,0.)
  244.       IROW1=NTEQA(I)
  245.       RHS(IROW1)= CMPLX(1.,0.)
  246. C**
  247. C     D      WRITE(*,*) '  NETWK: CALL SOLGF AFTER 39'
  248. C**
  249.       CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
  250.      1 NEQZ2,IP,LD2,LD3,IRESRV)
  251. C**
  252. C     D      WRITE(*,*) '  NETWK: RTRN SOLGF AFTER 39'
  253. C     D      WRITE(*,*) '  NETWK: CALL CABC AFTER 39'
  254. C**
  255.       CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  256.      1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
  257. C**
  258. C     D      WRITE(*,*) '  NETWK: RTRN CABC AFTER 39'
  259. C**
  260.       DO 40 J=1,NTEQ
  261.       IROW1=NTEQA(J)
  262. 40    CMN(I,J)=CMN(I,J)+RHS(IROW1)
  263. 41    CONTINUE
  264. C
  265. C     FACTOR NETWORK EQUATION MATRIX
  266. C
  267.       CALL FACTR(CMN,SCRATC,NTEQ,NDIMN,IPNT,LD2)
  268. C
  269. C     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT
  270. C     INTERACTIONS
  271. C
  272. 42    IF (NONET.EQ.0) GO TO 48
  273.       DO 43 I=1,NEQT
  274.       RHS(I)=EINC(I)
  275. 43      CONTINUE
  276. C**
  277. C     D      WRITE(*,*) '  NETWK: CALL SOLGF, CABC AFTER 43'
  278. C**
  279.       CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
  280.      1 NEQZ2,IP,LD2,LD3,IRESRV)
  281.       CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  282.      1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
  283.       DO 44 I=1,NTEQ
  284.       IROW1=NTEQA(I)
  285. 44    RHNT(I)=RHNX(I)+RHS(IROW1)
  286. C
  287. C     SOLVE NETWORK EQUATIONS
  288. C
  289. C**
  290. C     D      WRITE(*,*) '  NETWK: CALL SOLVE'
  291. C**
  292.       CALL SOLVE(CMN,RHNT,SCRATC,NTEQ,NDIMN,IPNT,LD2)
  293. C**
  294. C     D      WRITE(*,*) '  NETWK: RTRN SOLVE'
  295. C**
  296. C     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO
  297. C     STRUCTURE AND SOLVE FOR INDUCED CURRENT
  298. C
  299.       DO 45 I=1,NTEQ
  300.       IROW1=NTEQA(I)
  301.       EINC(IROW1)=EINC(IROW1)-RHNT(I)
  302. 45      CONTINUE
  303. C**
  304. C     D      WRITE(*,*) '  NETWK: CALL SOLGF, CABC AFTER 45'
  305. C**
  306.       CALL SOLGF(CM,CMB,CMC,CMD,EINC,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
  307.      1 NEQZ2,IP,LD2,LD3,IRESRV)
  308.       CALL CABC(EINC,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  309.      1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
  310.       IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,61)
  311.       IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,60)
  312.       DO 46 I=1,NTEQ
  313.       IROW1=NTEQA(I)
  314.       VLT=RHNT(I)*T1X(IROW1)*WLAM
  315.       CUX=EINC(IROW1)*WLAM
  316.       YMIT=CUX/VLT
  317.       ZPED=VLT/CUX
  318.       IROW2=ITAG(IROW1)
  319.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  320.       PNLS=PNLS-PWR
  321. 46    IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,62) IROW2,IROW1,
  322.      1 VLT,CUX,ZPED,YMIT,PWR
  323.       IF (NTSC.EQ.0) GO TO 49
  324.       DO 47 I=1,NTSC
  325.       IROW1=NTSCA(I)
  326.       VLT=VSRC(I)
  327.       CUX=EINC(IROW1)*WLAM
  328.       YMIT=CUX/VLT
  329.       ZPED=VLT/CUX
  330.       IROW2=ITAG(IROW1)
  331.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  332.       PNLS=PNLS-PWR
  333. 47    IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,62)  IROW2,IROW1,
  334.      1 VLT,CUX,ZPED,YMIT,PWR
  335.       GO TO 49
  336. C
  337. C     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
  338. C
  339. 48      CONTINUE
  340. C**
  341. C     D      WRITE(*,*) '  NETWK: CALL SOLGF, CABC AFTER 48'
  342. C**
  343.       CALL SOLGF(CM,CMB,CMC,CMD,EINC,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
  344.      1 NEQZ2,IP,LD2,LD3,IRESRV)
  345.       CALL CABC(EINC,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  346.      1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
  347. C**
  348.       NTSC=0
  349. 49    IF (NSANT+NVQD.EQ.0) RETURN
  350.       IF(NAMPRT.EQ.0) WRITE(IW,63)
  351.       IF(NAMPRT.EQ.0) WRITE(IW,60)
  352.       IF (NSANT.EQ.0) GO TO 56
  353.       DO 55 I=1,NSANT
  354.       ISC1=ISANT(I)
  355.       VLT=VSANT(I)
  356.       IF (NTSC.EQ.0) GO TO 51
  357.       DO 50 J=1,NTSC
  358.       IF (NTSCA(J).EQ.ISC1) GO TO 52
  359. 50    CONTINUE
  360. 51    CUX=EINC(ISC1)*WLAM
  361.       IROW1=0
  362.       GO TO 54
  363. 52    IROW1=NDIMNP-J
  364.       CUX=RHNX(IROW1)
  365.       DO 53 J=1,NTEQ
  366. 53    CUX=CUX-CMN(J,IROW1)*RHNT(J)
  367.       CUX=(EINC(ISC1)+CUX)*WLAM
  368. 54    YMIT=CUX/VLT
  369.       ZPED=VLT/CUX
  370.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  371.       PIN=PIN+PWR
  372.       IF (IROW1.NE.0) PNLS=PNLS+PWR
  373.       IROW2=ITAG(ISC1)
  374. 55      IF(NAMPRT.EQ.0) WRITE(IW,62)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
  375. 56    IF (NVQD.EQ.0) RETURN
  376.       DO 57 I=1,NVQD
  377.       ISC1=IVQD(I)
  378.       VLT=VQD(I)
  379.       CUX=DCMPLX(AIR(ISC1),AII(ISC1))
  380.       YMIT=DCMPLX(BIR(ISC1),BII(ISC1))
  381.       ZPED=CMPLX(CIR(ISC1),CII(ISC1))
  382.       PWR=T1X(ISC1)*TP*.5
  383.       CUX=(CUX-YMIT*DSIN(PWR)+ZPED*DCOS(PWR))*WLAM
  384.       YMIT=CUX/VLT
  385.       ZPED=VLT/CUX
  386.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  387.       PIN=PIN+PWR
  388.       IROW2=ITAG(ISC1)
  389. 57      IF(NAMPRT.EQ.0) WRITE(IW,64)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
  390. C**
  391. C     D      WRITE(*,*) '  NETWK: RETURN AT END'
  392. C**
  393.       RETURN
  394. C
  395. 58    FORMAT (///,3X,47HMAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT,
  396.      121H ADMITTANCE MATRIX IS,1P,E10.3,13H FOR SEGMENTS,I5,
  397.      24H AND,I5,/,3X,25HRMS RELATIVE ASYMMETRY IS,E10.3)
  398. 59    FORMAT (1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL')
  399. 60    FORMAT (/,3X,3HTAG,3X,4HSEG.,4X,15HVOLTAGE (VOLTS),9X,14HCURRENT (
  400.      1AMPS),9X,16HIMPEDANCE (OHMS),8X,17HADMITTANCE (MHOS),6X,5HPOWER,/,
  401.      23X,3HNO.,3X,3HNO.,4X,4HREAL,8X,5HIMAG.,3(7X,4HREAL,8X,5HIMAG.),5X,
  402.      37H(WATTS))
  403. 61    FORMAT (///,27X,66H- - - STRUCTURE EXCITATION DATA AT NETWORK CONN
  404.      1ECTION POINTS - - -)
  405. 62    FORMAT (2(1X,I5),1P,9E12.5)
  406. 63    FORMAT (///,42X,36H- - - ANTENNA INPUT PARAMETERS - - -)
  407. 64    FORMAT (1X,I5,2H *,I4,1P,9E12.5)
  408.       END
  409. C
  410. C
  411. C
  412.       SUBROUTINE CABC(CURX,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  413.      1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
  414. C
  415. C     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND
  416. C     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE
  417. C     CURRENT VECTOR CUR.
  418. C
  419.       REAL*8 TP,CCJX,AX,BX,CX,AIR,AII,BIR,BII,CIR,CII,AR,AI,SH
  420. CLARGE CURX
  421.       COMPLEX CURX
  422.       COMPLEX*16 CCJ
  423.       COMPLEX*16 VQD,VSANT,VQDS
  424.       COMPLEX*16 CURD,CS1,CS2
  425.       INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM
  426.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  427.       COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
  428.      1 IPCON(10),NPCON
  429.       COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
  430.      1 IQDS(30),NVQD,NSANT,NQDS
  431.       DIMENSION CURX(LD3),CCJX(2),ICON1(LD),ICON2(LD)
  432.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  433.       DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),BI(LD)
  434.       EQUIVALENCE (CCJ,CCJX)
  435.       DATA TP/6.283185308D0/,CCJX/0.,-0.01666666667D0/
  436. C**
  437. C     E      WRITE(*,*) '   CABC: START'
  438. C**
  439.       IF (N.EQ.0) GO TO 6
  440.       DO 1 I=1,N
  441.       AIR(I)=0.
  442.       AII(I)=0.
  443.       BIR(I)=0.
  444.       BII(I)=0.
  445.       CIR(I)=0.
  446.       CII(I)=0.
  447. 1      CONTINUE
  448. C**
  449.       DO 2 I=1,N
  450. C      AR=DREAL(CURX(I))
  451. C      AI=DIMAG(CURX(I))
  452.       AR=REAL(CURX(I))
  453.       AI=IMAG(CURX(I))
  454.       IDM1=1
  455.       CALL TBF(T1X,BI,ICON1,ICON2,IDM1,I,LD)
  456.       DO 2 JX=1,JSNO
  457.       J=JCO(JX)
  458.       AIR(J)=AIR(J)+AX(JX)*AR
  459.       AII(J)=AII(J)+AX(JX)*AI
  460.       BIR(J)=BIR(J)+BX(JX)*AR
  461.       BII(J)=BII(J)+BX(JX)*AI
  462.       CIR(J)=CIR(J)+CX(JX)*AR
  463.       CII(J)=CII(J)+CX(JX)*AI
  464. 2      CONTINUE
  465.       IF (NQDS.EQ.0) GO TO 4
  466. C**
  467.       IDM1=0
  468.       DO 3 IS=1,NQDS
  469.       I=IQDS(IS)
  470.       JXX=ICON1(I)
  471.       ICON1(I)=0
  472.       CALL TBF(T1X,BI,ICON1,ICON2,IDM1,I,LD)
  473.       ICON1(I)=JXX
  474.       SH=T1X(I)*.5
  475.       CURD=CCJ*VQDS(IS)/((DLOG(2.*SH/BI(I))-1.)*(BX(JSNO)*DCOS(TP*SH)
  476.      1 +CX(JSNO)*DSIN(TP*SH))*WLAM)
  477.       AR=DREAL(CURD)
  478.       AI=DIMAG(CURD)
  479.       DO 3 JX=1,JSNO
  480.       J=JCO(JX)
  481.       AIR(J)=AIR(J)+AX(JX)*AR
  482.       AII(J)=AII(J)+AX(JX)*AI
  483.       BIR(J)=BIR(J)+BX(JX)*AR
  484.       BII(J)=BII(J)+BX(JX)*AI
  485.       CIR(J)=CIR(J)+CX(JX)*AR
  486.       CII(J)=CII(J)+CX(JX)*AI
  487. 3      CONTINUE
  488. 4      CONTINUE
  489.       DO 5 I=1,N
  490.       CURX(I)=CMPLX(AIR(I)+CIR(I),AII(I)+CII(I))
  491. 5      CONTINUE
  492. 6      CONTINUE
  493.       IF (M.EQ.0) RETURN
  494. C     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
  495.       K=LD-M
  496.       JCO1=N+2*M+1
  497.       JCO2=JCO1+M
  498.       DO 7 I=1,M
  499.       K=K+1
  500.       JCO1=JCO1-2
  501.       JCO2=JCO2-3
  502.       CS1=CURX(JCO1)
  503.       CS2=CURX(JCO1+1)
  504.       CURX(JCO2)=CS1*T1X(K)+CS2*T2X(K)
  505.       CURX(JCO2+1)=CS1*T1Y(K)+CS2*T2Y(K)
  506. 7     CURX(JCO2+2)=CS1*T1Z(K)+CS2*T2Z(K)
  507.       RETURN
  508.       END
  509. C
  510. C
  511. C
  512.       SUBROUTINE SOLGF(A,B,C,D,XY,Y,NP,N1,N,MP,M1,M,N1C,N2C,N2CZ,
  513.      1 IP,LD2,LD3,IRESRV)
  514. C     SOLVE FOR CURRENT IN N.G.F. PROCEDURE
  515.       INTEGER*4 NP,N1,N,MP,M1,M,N1C,N2C
  516.       REAL*8 AX,BX,CX
  517. CLARGE: A,B,C,D,XY
  518.       COMPLEX A,B,C,D,XY
  519.       COMPLEX*16 Y,SUM
  520.       DIMENSION B(N1C,1),C(N1C,1),D(N2CZ,1),XY(LD3),
  521.      1 IP(LD2),Y(LD2)
  522.       COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
  523.      1 IPCON(10),NPCON
  524.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  525.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  526.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  527.       IFL=14
  528.       IF (ICASX.GT.0) IFL=13
  529. C**
  530. C     D      WRITE(*,*) '   SOLGF: START IFL=',IFL,' ICASX=',ICASX,' N2C=',N2C
  531. C**
  532.       IF (N2C.GT.0) GO TO 1
  533. C     NORMAL SOLUTION.  NOT N.G.F.
  534.       CALL SOLVES(A,XY,Y,N1C,NP,N,MP,M,IP,1,13,IFL,LD2,IRESRV)
  535.       GOTO 22
  536. 1     IF (N1.EQ.N.OR.M1.EQ.0) GO TO 5
  537. C     REORDER EXCITATION ARRAY
  538.       N2=N1+1
  539.       JJ=N+1
  540.       NPM=N+2*M1
  541.       DO 2 I=N2,NPM
  542. 2     Y(I)=XY(I)
  543.       J=N1
  544.       DO 3 I=JJ,NPM
  545.       J=J+1
  546. 3     XY(J)=Y(I)
  547.       DO 4 I=N2,N
  548.       J=J+1
  549. 4     XY(J)=Y(I)
  550. 5     NEQS=NSCON+2*NPCON
  551.       IF (NEQS.EQ.0) GO TO 7
  552.       NEQ=N1C+N2C
  553.       NEQS=NEQ-NEQS+1
  554. C     COMPUTE INV(A)E1
  555.       DO 6 I=NEQS,NEQ
  556. 6     XY(I)=(0.,0.)
  557. 7     CALL SOLVES(A,XY,Y,N1C,NP,N1,MP,M1,IP,1,13,IFL,LD2,IRESRV)
  558.       NI=0
  559.       NPB=NPBL
  560. C     COMPUTE E2-C(INV(A)E1)
  561.       DO 10 JJ=1,NBBL
  562.       IF (JJ.EQ.NBBL) NPB=NLBL
  563.       IF (ICASX.GT.1) READ (15) ((C(I,J),I=1,N1C),J=1,NPB)
  564.       II=N1C+NI
  565.       DO 9 I=1,NPB
  566.       SUM=(0.,0.)
  567.       DO 8 J=1,N1C
  568. 8     SUM=SUM+C(J,I)*XY(J)
  569.       J=II+I
  570. 9     XY(J)=XY(J)-SUM
  571. 10    NI=NI+NPBL
  572. C**
  573. C     D      WRITE(*,*) '   SOLGF: OPEN 15'
  574. C**
  575.       OPEN (15,FORM='UNFORMATTED')
  576.       JJ=N1C+1
  577. C     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
  578.       IF (ICASX.GT.1) GO TO 11
  579.       CALL SOLVE(D,XY(JJ),Y,N2C,N2C,IP(JJ),LD2)
  580.       GO TO 13
  581. 11    IF (ICASX.EQ.4) GO TO 12
  582.       NI=N2C*N2C
  583.       READ (11) (B(J,1),J=1,NI)
  584.       REWIND 11
  585.       CALL SOLVE(B,XY(JJ),Y,N2C,N2C,IP(JJ),LD2)
  586.       GO TO 13
  587. 12    NBLSYS=NBLSYM
  588.       NPSYS=NPSYM
  589.       NLSYS=NLSYM
  590.       ICASS=ICASE
  591.       NBLSYM=NBBL
  592.       NPSYM=NPBL
  593.       NLSYM=NLBL
  594.       ICASE=3
  595.       REWIND 11
  596. C**
  597. C     D      WRITE(*,*) '   SOLGF: OPEN 16'
  598. C**
  599.       OPEN (16,FORM='UNFORMATTED')
  600. C**
  601. C     D      WRITE(*,*) '   SOLGF: CALL LTSOLV'
  602. C**
  603.       CALL LTSOLV (B,XY(JJ),Y,IP(JJ),N2C,N2C,1,11,16,LD2)
  604. C**
  605. C     D      WRITE(*,*) '   SOLGF: RTRN LTSOLV'
  606. C**
  607.       REWIND 11
  608.       REWIND 16
  609.       NBLSYM=NBLSYS
  610.       NPSYM=NPSYS
  611.       NLSYM=NLSYS
  612.       ICASE=ICASS
  613. 13    NI=0
  614.       NPB=NPBL
  615. C     COMPUTE INV(A)E1-(INV(A)B)I2 = I1
  616.       DO 16 JJ=1,NBBL
  617.       IF (JJ.EQ.NBBL) NPB=NLBL
  618.       IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB)
  619.       II=N1C+NI
  620.       DO 15 I=1,N1C
  621.       SUM=(0.,0.)
  622.       DO 14 J=1,NPB
  623.       JP=II+J
  624. 14    SUM=SUM+B(I,J)*XY(JP)
  625. 15    XY(I)=XY(I)-SUM
  626. 16    NI=NI+NPBL
  627. C**
  628. C     D      WRITE(*,*) '   SOLGF: OPEN 14'
  629. C**
  630.       OPEN (14,FORM='UNFORMATTED')
  631.       IF (N1.EQ.N.OR.M1.EQ.0) GO TO 20
  632. C     REORDER CURRENT ARRAY
  633.       DO 17 I=N2,NPM
  634. 17    Y(I)=XY(I)
  635.       JJ=N1C+1
  636.       J=N1
  637.       DO 18 I=JJ,NPM
  638.       J=J+1
  639. 18    XY(J)=Y(I)
  640.       DO 19 I=N2,N1C
  641.       J=J+1
  642. 19    XY(J)=Y(I)
  643. 20    IF (NSCON.EQ.0) GO TO 22
  644.       J=NEQS-1
  645.       DO 21 I=1,NSCON
  646.       J=J+1
  647.       JJ=ISCON(I)
  648. 21    XY(JJ)=XY(J)
  649. 22      CONTINUE
  650. C**
  651. C     D      WRITE(*,*) '   SOLGF: RETURN'
  652. C**
  653.       RETURN
  654.       END
  655.